<%
'Publisher:WangJinkun.Date:2011-06-01 
'Copyright (C) evil_god@163.com (http://blog.163.com/evil_god).All rights reserved.

' ASCII码对应表 chr(9):Tab、chr(10):换行符、chr(13):回车、chr(32):空格、chr(34):双引号 chr(39):'

'----------字符串处理系列函数Start----------

'函数名：gotTopic
'作  用：截字符串，汉字一个算两个字符，英文算一个字符
'参  数：str   ----原字符串
'       strlen ----截取长度
'返回值：截取后的字符串

function gotTopic(ByVal str,ByVal strlen)
	if str="" then
		gotTopic=""
		exit function
	end if
	dim l,t,c,i
	str=replace(replace(replace(replace(str,"&nbsp;"," "),"&quot;",chr(34)),"&gt;",">"),"&lt;","<")
	l=len(str)
	t=0
	for i=1 to l
		c=Asc(Mid(str,i,1))
		if c<0 then c=c+65536
		if c>255 then
			t=t+2
		else
			t=t+1
		end if
		if t>=strlen then
			gotTopic=left(str,i) & "…"
			exit for
		else
			gotTopic=str
		end if
	next
	gotTopic=replace(replace(replace(gotTopic,chr(34),"&quot;"),">","&gt;"),"<","&lt;")
end function

'函数名：strLength
'作  用：求字符串长度。汉字算两个字符，英文算一个字符。
'参  数：str  ----要求长度的字符串
'返回值：字符串长度
function strLength(ByVal str)
	dim l,t,c,i
	l=len(str)
	t=0
	for i=1 to l
		c=Asc(Mid(str,i,1))
		if c<0 then c=c+65536
		if c>255 then
			t=t+2
		else
			t=t+1
		end if
	next
	strLength=t
end function

'函数名：JoinChar
'作  用：向地址中加入 ? 或 &
'参  数：strUrl  ----网址
'返回值：加了 ? 或 & 的网址
function JoinChar(ByVal strUrl)
	if strUrl="" then
		JoinChar=""
		exit function
	end if
	if InStr(strUrl,"?")<len(strUrl) then 
		if InStr(strUrl,"?")>1 then
			if InStr(strUrl,"&")<len(strUrl) then 
				JoinChar=strUrl & "&"
			else
				JoinChar=strUrl
			end if
		else
			JoinChar=strUrl & "?"
		end if
	else
		JoinChar=strUrl
	end if
end function

'函数名：RemoveHTML
'作  用：过滤HTML代码
'参  数：strHTML   ----原字符串
'返回值：过滤后的字符串
Function RemoveHTML(ByVal str) 
     Dim re 
     Set re=New RegExp 
     re.Pattern="<.*?>" 
     re.IgnoreCase=True     
     re.Global=True 
     str=re.Replace(str,"") 
     Set re=Nothing 
     RemoveHTML=str
End Function

'过滤script代码如js代码
Function RemoveScriptTag(ByVal ContentStr)
	Dim ClsTempLoseStr,regEx
	ClsTempLoseStr = Cstr(ContentStr)
	Set regEx = New RegExp
		regEx.Pattern = "(<script){1,}[^<>]*>[^\0]*(<\/script>){1,}"
		regEx.IgnoreCase = True
		regEx.Global = True
		ClsTempLoseStr = regEx.Replace(ClsTempLoseStr,"")
	Set regEx = Nothing
	RemoveScriptTag = ClsTempLoseStr
End Function

'过滤style代码，防止外部style影响页面变形
Function RemoveStyleTag(ByVal ContentStr)
	Dim ClsTempLoseStr,regEx
	ClsTempLoseStr = Cstr(ContentStr)
	Set regEx = New RegExp
		regEx.Pattern = "(<style)+[^<>]*>[^\0]*(<\/style>)+"
		regEx.IgnoreCase = True
		regEx.Global = True
		ClsTempLoseStr = regEx.Replace(ClsTempLoseStr,"")
	Set regEx = Nothing
	RemoveStyleTag = ClsTempLoseStr
End Function

'函数名：Replace_Text
'作  用：过滤SQL非法字符并格式化html代码 建议使用在<input>中，解决value=""""值截漏问题
'参  数：fString   ----原字符串
'返回值：过滤后的字符串
function Replace_Text(ByVal fString)
	if isnull(fString) then
		Replace_Text=""
	else
		fString=trim(fString)
		fString=replace(fString,"'","&#39;")
		fString=replace(fString,chr(34),"&#34;")
		'fString=replace(fString,"--","—")
		'fString=server.htmlencode(fString)
		Replace_Text=fString
	end if 
end function

'函数名：escape_char
'作  用：js应用中字符转义函数，防止js出错
'参  数：fString   ----原字符串
'返回值：转换后的字符串
function escape_char(ByVal str)
    str=replace(str,"&#39;","\&#39;")
    str=replace(str,"&#34;","\&#34;")
    str=replace(str,chr(39),chr(47)&chr(39))
    str=replace(str,chr(34),chr(47)&chr(34))
	escape_char = str
end function

function html_encode(ByVal str)
	dim result
	dim l
	if isNULL(str) then
		html_encode=""
	else
		l=len(str)
		result=""
		dim i
		for i = 1 to l
			select case mid(str,i,1)
			case "<"
				result=result+"&lt;"
			case ">"
				result=result+"&gt;"
			case chr(13)
				result=result+"<br>"
			case chr(34)
				result=result+"&quot;"
			case "&"
				result=result+"&amp;"
			case chr(32)
				if i+1<=l and i-1>0 then
					if mid(str,i+1,1)=chr(32) or mid(str,i+1,1)=chr(9) or mid(str,i-1,1)=chr(32) or mid(str,i-1,1)=chr(9) then	
						result=result+"&nbsp;"
					else
						result=result+" "
					end if
				else
					result=result+"&nbsp;"	
				end if
			case chr(9)
				result=result+"    "
			case else
				result=result+mid(str,i,1)
			end select
		next
		html_encode=result
	end if
end function


'函数名：ceil
'作  用：取上行整数
'参  数：value   ----原浮点型
'返回值：整数
Function ceil(ByVal value)
	If value > 0 then
		value = FIX(value) + Sgn(value-FIX(value))
	Else
		value = FIX(value)
	End If
	ceil=value
End function

'函数名：floor
'作  用：取下行整数
'参  数：value   ----原浮点型
'返回值：整数
Function floor(ByVal value)
	If value >= 0 then
		value = FIX(value)
	Else
		value = FIX(value) + Sgn(value-FIX(value))
	End If
	floor=value
End function

'函数名：iif
'作  用：仿三元操作
'参  数：expr，truepart，falsepart
'返回值：字符串
function iif(ByVal expr, ByVal truepart, ByVal falsepart)
	if expr then
		IIf=truepart
	else
		IIf=falsepart
	end if
end function

'函数名：RemoveSameArrValue
'作  用：剔除数组中重复的值，建立无重复值的新数组
'参  数：ArrC 原数组
'返回值：Array
Function RemoveSameArrValue(ByVal ArrC)
	dim tempArr()
	dim tempArr_i:tempArr_i=0
	for ArrC_i=0 to ubound(ArrC)
		if tempArr_i=0 then
			ReDim Preserve tempArr(tempArr_i)
			tempArr(tempArr_i)=ArrC(ArrC_i)
			tempArr_i=tempArr_i+1
		else
			if InArray(ArrC(ArrC_i),tempArr)=False then
				ReDim Preserve tempArr(tempArr_i)
				tempArr(tempArr_i)=ArrC(ArrC_i)
				tempArr_i=tempArr_i+1
			end if
		end if
	next
	RemoveSameArrValue=tempArr
End Function

'函数名：InArray
'作  用：查看一个值是否出现在一个数组中
'参  数：sValue 查询值 aArray 查询数组
'返回值：boolean
Function InArray(ByVal sValue, ByVal aArray)
	Dim x
	InArray = False
	For Each x In aArray
		If trim(x) = trim(sValue) Then
			InArray = True
			Exit For
		End If
	Next
End Function

'----------字符串处理系列函数End----------


'----------验证处理系列函数Start----------

'函数名：ChkMail
'作  用：检查Email地址合法性
'参  数：Email ----要检查的Email地址
'返回值：True  ----Email地址合法
'       False ----Email地址不合法
Function ChkMail(ByVal Email) 
	Dim Rep
	Set Rep = New RegExp 
	Rep.Pattern = "^([0-9a-zA-Z]([-.\w]*[0-9a-zA-Z])*@(([0-9a-zA-Z])+([-\w]*[0-9a-zA-Z])*\.)+[a-zA-Z]{2,9})$"
	If Not Rep.Test(Email) Then 
		ChkMail = False 
	Else
		ChkMail = True
	End If
	Set Rep = Nothing 
End Function


'函数：CheckIn
'描述：检测参数是否有SQL危险字符
'参数：str要检测的数据
'返回：FALSE：安全 TRUE：不安全
function CheckIn(ByVal str)
	if instr(1,str,chr(39))>0 or instr(1,str,chr(34))>0 or instr(1,str,chr(59))>0 then
		CheckIn=true
	else
		CheckIn=false
	end if
end function

'----------验证处理系列函数End-----------


'----------获取服务端参数系列函数Start----------

'获取用户真实IP函数
Function GetIP()
GetIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If GetIP = "" Then GetIP = Request.ServerVariables("REMOTE_ADDR")
End Function

'----------获取服务端参数系列函数End----------


'----------asp Ajax系列函数Start----------

'函数名：getHTTPPage
'作  用：获取远程文件内容
'参  数：url  '地址， Cset ’字符编码 
'返回值：字符串,False  ---成功，失败
Function getHTTPPage(ByVal url,ByVal Cset)
	if Cset="" then Cset="gb2312" 
	set Http=Server.CreateObject("Microsoft.XMLHTTP") 
	Http.open "GET",url,false 
	Http.send() 
	if Http.readystate<>4 then 
	   getHTTPPage=False
	else
		getHTTPPage=bytesToBstr(Http.responseBody,Cset) 
		If Err.number<>0 then 
		   getHTTPPage = False
		   Err.Clear 
		End If   
	end if 
	set Http=nothing 
End function

Function bytesToBstr(ByVal body,ByVal Cset) 
	if Cset="" then Cset="gb2312" 
	dim objstream 
	set objstream = Server.CreateObject("adodb.stream") 
	objstream.Type = 1 
	objstream.Mode =3 
	objstream.Open 
	objstream.Write body 
	objstream.Position = 0 
	objstream.Type = 2 
	objstream.Charset = Cset 
	BytesToBstr = objstream.ReadText 
	objstream.Close 
	set objstream = nothing 
End Function 

'----------asp Ajax系列函数End----------


'----------组件系列函数Start----------

'函数名：IsObjInstalled
'作  用：检查组件是否已经安装
'参  数：strClassString ----组件名
'返回值：True  ----已经安装
'       False ----没有安装
Function IsObjInstalled(ByVal strClassString)
	On Error Resume Next
	IsObjInstalled = False
	Err = 0
	Dim xTestObj
	Set xTestObj = Server.CreateObject(strClassString)
	If 0 = Err Then IsObjInstalled = True
	Set xTestObj = Nothing
	Err = 0
End Function

'函数名：SendEmail
'作  用：邮件函数
'参  数：FName：发件者名称，ToWho：邮件接收者（多个使用英文格式";"），subject：邮件主题，mailbody：邮件正文，pic：附件
function SendEmail(ByVal FName,ByVal ToWho,ByVal subject,ByVal mailbody,ByVal pic)
	if MailSend_con=True and MailOpen_con=True then
		set SendEmailObj=new MailSender
		SendEmailObj.Mailhostserver_con = Mailhostserver_con
		SendEmailObj.MailUser_con = MailUser_con
		SendEmailObj.MailPwd_con = MailPwd_con
		SendEmailObj.MailSMTP_con = MailSMTP_con
		SendEmailObj.MailPort_con = MailPort_con
		SendEmailObj.MailTLS_con = MailTLS_con
		SendEmailObj.MailSendApp_con = MailSendApp_con
		SendEmail=SendEmailObj.mail(FName,ToWho,subject,mailbody,pic)
	else
		SendEmail="Error: E-mail function, the system setting is off."
	end if
end function

'----------组件系列函数End----------


'----------前台互交系列函数Start----------

'过程名：WriteErrMsg
'作  用：显示错误提示信息
'参  数：errMsg
function WriteErrMsg(ByVal errMsg)
	dim tempStr
	tempStr=tempStr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=utf-8'>"
	tempStr=tempStr & "<link href='style.css' rel='stylesheet' type='text/css'></head><body style='padding-top:50px'>"
	tempStr=tempStr & "<table cellpadding=0 cellspacing=0 border=0 width='400' style='border:1px solid #cccccc' align=center>"
	tempStr=tempStr & "  <tr align='center'><td height='30' style='background:#efefef'><strong>错误信息！</strong></td></tr>"
	tempStr=tempStr & "  <tr><td height='100' style='padding:10px'><b>产生错误的可能原因：</b><br>" & errMsg &"</td></tr>"
	tempStr=tempStr & "  <tr align='center'><td height='30'><a href='javascript:history.go(-1)'>【返回】</a></td></tr>"
	tempStr=tempStr & "</table>"
	tempStr=tempStr & "</body></html>"
	response.write tempStr
end function

'****************************************************
'过程名：WriteSuccessMsg
'作  用：显示成功提示信息
'参  数：SuccessMsg
'****************************************************
function WriteSuccessMsg(ByVal SuccessMsg)
	dim tempStr
	tempStr=tempStr & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=utf-8'>"
	tempStr=tempStr & "<link href='style.css' rel='stylesheet' type='text/css'></head><body style='padding-top:50px'>"
	tempStr=tempStr & "<table cellpadding=0 cellspacing=0 border=0 width='400' style='border:1px solid #cccccc' align=center>"
	tempStr=tempStr & "  <tr align='center'><td height='30' style='background:#efefef'><strong>恭喜你！</strong></td></tr>"
	tempStr=tempStr & "  <tr><td height='100' style='padding:10px'>" & SuccessMsg &"</td></tr>"
	tempStr=tempStr & "  <tr align='center'><td height='30'><a href='javascript:history.go(-1)'>【返回】</a></td></tr>"
	tempStr=tempStr & "</table>"
	tempStr=tempStr & "</body></html>"
	response.write tempStr
end function

' 弹出对话框
function Alert(ByVal message)
	message = replace(message,"'","\'")
	Response.Write ("<script>alert('" & message & "')</script>")
end function

'右下角弹出窗消息 需要ctunion.js配合使用
function ShowMessage(ByVal Msg,ByVal Parent,ByVal keepTimes,ByVal LaterTimes,ByVal msgWidth,ByVal msgHeight)
	if Parent="parent" then Parent="parent."
	if LaterTimes="" then parent="0"
	response.Write("<script>setTimeout(function(){"&Parent&"showMessage('"&escape_char(Msg)&"',"&keepTimes&",'"&msgWidth&"','"&msgHeight&"')},"&LaterTimes&")</script>")
end function

' 返回上一页，一般用在判断信息提交是否完全之后
function GoBack()
	Response.write ("<script>history.go(-1)</script>")
end function

' 重定向另外的连接
function Go(ByVal url)
	Response.write ("<script>location='" & url & "'</script>")
end function

' 指定秒数重定向另外的连接
function GoPage(ByVal url,ByVal s)
	s=s*1000
	Response.Write "<SCRIPT LANGUAGE='javascript'>"
	if left(lcase(url),7)="js:back" then  '例：js:back:-2
		jNum=mid(url,9)
		if jNum="" then JNum=-1
		Response.Write "window.setTimeout("&chr(34)&"history.go("&jNum&")"&chr(34)&","&s&")"
	else
		Response.Write "window.setTimeout("&chr(34)&"location='"&url&"'"&chr(34)&","&s&")"
	end if
	Response.Write "</script>"
end function

'----------前台互交系列函数End----------


'----------其他系列函数Start----------

'函数名：GetRndCode
'作  用：获取随机码
'参  数：CodeLen   ----定义随机码的长度
'返回值：字符串
Function GetRndCode(ByVal CodeLen)
	Randomize
	Dim m_strRandArray,m_intRandlen,m_strRandomize,i
	m_strRandArray = Array(0,1,2,3,4,5,6,7,8,9,"A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P","Q","R","S","T","U","V","W","X","Y","Z")
	if isnumeric(CodeLen) and CodeLen>0 then   '定义随机码的长度
		m_intRandlen = CodeLen 
		for i = 1 to m_intRandlen
			m_strRandomize = m_strRandomize & m_strRandArray(Int((ubound(m_strRandArray)*Rnd)))
		next
		GetRndCode = m_strRandomize
	else
		GetRndCode = False 
	end if
End Function

'----------其他系列函数End----------

'Publisher:WangJinkun.Date:2011-06-01 
'Copyright (C) evil_god@163.com (http://blog.163.com/evil_god).All rights reserved.
%>